'For Grape
Sub Export_Excel_Columns_To_New_Excel_In_Single_Sheet()
    Dim excelApp As Excel.Application '创建 Excel 应用程序对象
    Dim excelWorkbook As Excel.Workbook '创建 Excel 工作簿对象
    Dim excelWorksheet As Excel.Worksheet '创建 Excel 工作表对象
    Dim unNeedSheets() '不需要的Sheet
    Dim neededColumns() '需要的列号
    Dim columnTemp As Integer '临时列号
    Dim rowCount As Long '总行数
    Dim errorMsg As String '错误信息
    Dim errorCount As Long '错误数量
    Dim isFirstSheet As Boolean '是否是第一个Sheet
    Dim headerLength As Integer '标题长度
    Dim maxLength As Long
    Dim rng As Range '最终Excel范围
    Dim rngDel As Range

    maxLength = 100000

    isFirstSheet = True
    headerLength = 1

    On Error GoTo ErrorHandler

    unNeedSheets = Array(1, 2) '不需要的Sheet序号
    neededColumns = Array("B", "C", "E") '需要的列号

    Set excelApp = CreateObject("Excel.Application") '创建新的 Excel 实例
    'excelApp.Visible = True '将 Excel 应用程序设置为可见，以便查看导出的结果
    Set excelWorkbook = excelApp.Workbooks.Add '打开 Excel 工作簿
    Set excelWorksheet = excelWorkbook.Sheets(1) '创建新的工作表

    rowCount = 1 '初始化rowCount

    For Each ws In Worksheets '遍历所有Sheet
        If UBound(Filter(unNeedSheets, ws.Index)) < 0 Then '判断是否跳过
            'excelWorksheet.Cells(rowCount, 1).MergeArea.Value = ws.Name '设置Sheet的名称
            'rowCount = rowCount + 1
            columnTemp = 1 '初始化columnTemp

            For Each neededColumn In neededColumns
                ws.Range(neededColumn & IIf(isFirstSheet, 1, 1 + headerLength) & ":" & neededColumn & maxLength).Copy
                excelWorksheet.Range(ConvertToLetter(columnTemp) & rowCount).PasteSpecial xlPasteValues
                'excelWorksheet.Range(ConvertToLetter(columnTemp) & rowCount).PasteSpecial xlPasteFormats
                columnTemp = columnTemp + 1
            Next

            rowCount = excelWorksheet.UsedRange.Find("*", LookIn:=xlValues, searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1 '计算现有总行数
            'rowCount = excelWorksheet.UsedRange.Rows.Count + 1
            'rowCount = excelWorksheet.UsedRange.End(xlUp).Row + 1
            isFirstSheet = False
        End If
    Next

    excelWorksheet.Range("B:B").TextToColumns 'TextToColumns

    Set rng = excelWorksheet.Range("A:" & (ConvertToLetter(UBound(neededColumns) + 1))) '选取范围
    rng.RemoveDuplicates Columns:=ConvertLengthToArray(UBound(neededColumns) + 1), Header:=xlYes '去重

    excelApp.Visible = True

ErrorHandler:     '捕获错误
    errorCount = errorCount + 1
    'errorMsg = "Error #" & Err.Number & " occurred" & vbCrLf & "Description: " & Err.Description & vbCrLf & "In procedure ExportChartDataToExcel, line: " & Erl
    'MsgBox errorMsg, vbExclamation + vbOKOnly, "Error"
    'Dim userResponse As VbMsgBoxResult
    'userResponse = MsgBox("Do you want to continue running the macro?", vbQuestion + vbYesNo, "Continue?")
    If errorCount < 100 Then '100以内错误，回溯
        Resume
    Else
        excelApp.Visible = True '显示 Excel 应用程序界面
        Exit Sub
    End If
End Sub

'数字列号转换
Function ConvertToLetter(iCol As Integer) As String
    Dim iAlpha As Integer
    Dim iRemainder As Integer
    iAlpha = Int(iCol / 27)
    iRemainder = iCol - (iAlpha * 26)
    If iAlpha > 0 Then
       ConvertToLetter = Chr(iAlpha + 64)
    End If
    If iRemainder > 0 Then
       ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
    End If
End Function

Function ConvertLengthToArray(l As Integer) As Variant
    Dim arr As Variant
    ReDim arr(0 To l - 1)
    For i = 0 To l - 1
        arr(i) = i + 1
    Next i
    ConvertLengthToArray = arr
End Function